home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gnat1792.zip
/
gnat179b
/
t-adainc
/
s-taskin.adb
< prev
next >
Wrap
Text File
|
1994-05-19
|
7KB
|
258 lines
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G --
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (c) 1991,1992,1993, FSU, All Rights Reserved --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU Library General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. GNARL is distributed in the hope that it will be use- --
-- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- --
-- eral Library Public License for more details. You should have received --
-- a copy of the GNU Library General Public License along with GNARL; see --
-- file COPYING. If not, write to the Free Software Foundation, 675 Mass --
-- Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
-- This package body has to be eliminated once the offset calulation for
-- ATCB is done statically. Also, the temporary placement of queuing
-- primitives has to move back to Tasking.Queuing. (compiler error) ???
with System.Task_Primitives;
-- Used for, Task_Primitives.TCB_Ptr,
-- Task_Primitives.Self
with System.Storage_Elements;
-- Used for, Storage_Elements.Storage_Offset,
-- Storage_Elements."-"
-- Storage_Elements.Storage_Count
with System.Tasking.Runtime_Types;
-- Used for, Runtime_Types.Ada_Task_Control_Block;
with Unchecked_Conversion;
package body System.Tasking is
function "-"
(A : System.Address;
B : System.Address)
return Storage_Elements.Storage_Offset
renames Storage_Elements."-";
function "-"
(A : System.Address;
I : Storage_Elements.Storage_Offset)
return System.Address
renames Storage_Elements."-";
function Get_LL_TCB_Offset return Storage_Elements.Storage_Count;
LL_TCB_Offset : Storage_Elements.Storage_Count := Get_LL_TCB_Offset;
function Address_To_Task_ID is new
Unchecked_Conversion (System.Address, Task_ID);
function TCB_Ptr_To_Address is new
Unchecked_Conversion (Task_Primitives.TCB_Ptr, System.Address);
-----------------------
-- Get_LL_TCB_Offset --
-----------------------
function Get_LL_TCB_Offset return Storage_Elements.Storage_Count is
ATCB_Record : Runtime_Types.Ada_Task_Control_Block (0);
begin
return ATCB_Record.LL_TCB'Address - ATCB_Record'Address;
end Get_LL_TCB_Offset;
----------
-- Self --
----------
-- This is an INLINE_ONLY version of Self for use in the RTS.
function Self return Task_ID is
S : Task_Primitives.TCB_Ptr := Task_Primitives.Self;
begin
return Address_To_Task_ID (TCB_Ptr_To_Address (S) - LL_TCB_Offset);
end Self;
-- The following functions are in Tasking.Queuing.
-- However, because of the compiler intyernal error,
-- They are temporarily moved to here. ???
-------------
-- Enqueue --
-------------
-- Enqueue call at the end of entry_queue E
procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
begin
if E.Head = null then
E.Head := Call; -- E.Tail should also be null here
else
E.Tail.Next := Call;
end if;
E.Tail := Call;
Call.Next := E.Head; -- make circular linked-list
end Enqueue;
-------------
-- Dequeue --
-------------
-- Dequeue call from entry_queue E
procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
Prev : Entry_Call_Link;
begin
-- If empty queue, simply return
if E.Head = null then
return;
end if;
if E.Head = Call then
if E.Tail = Call then
E.Head := null; -- case of one element
E.Tail := null;
else
E.Head := Call.Next;
E.Tail.Next := E.Head;
end if;
-- Successfully dequeued
Call.Next := null;
else
-- At this point we know that the queue has more than one element
Prev := E.Head;
loop
if Prev.Next = Call then
Prev.Next := Call.Next;
if E.Tail = Call then
E.Tail := Prev;
end if;
-- Successfully dequeued
Call.Next := null;
exit;
end if;
-- Exit if call is not found
exit when Prev.Next = E.Tail;
Prev := Prev.Next;
end loop;
end if;
end Dequeue;
----------
-- Head --
----------
-- Return the head of entry_queue E
function Head (E : in Entry_Queue) return Entry_Call_Link is
begin
return E.Head;
end Head;
------------------
-- Dequeue_Head --
------------------
-- Remove and return the head of entry_queue E
procedure Dequeue_Head
(E : in out Entry_Queue;
Call : out Entry_Call_Link)
is
Temp : Entry_Call_Link;
begin
-- If empty queue, return null pointer
if E.Head = null then
Call := null;
return;
end if;
Temp := E.Head;
if E.Head = E.Tail then
E.Head := null; -- case of one element
E.Tail := null;
else
E.Head := Temp.Next;
E.Tail.Next := E.Head;
end if;
-- Successfully dequeued
Temp.Next := null;
Call := Temp;
end Dequeue_Head;
-------------
-- Onqueue --
-------------
-- Return True if Call is on any entry_queue at all
function Onqueue (Call : Entry_Call_Link) return Boolean is
begin
-- Utilize the fact that every queue is circular, so if Call
-- is on any queue at all, Call.Next must NOT be null.
return Call.Next /= null;
end Onqueue;
-------------------
-- Count_Waiting --
-------------------
-- Return number of calls on the waiting queue of E
function Count_Waiting (E : in Entry_Queue) return Natural is
Count : Natural;
Temp : Entry_Call_Link;
begin
Count := 0;
if E.Head /= null then
Temp := E.Head;
loop
Count := Count + 1;
exit when E.Tail = Temp;
Temp := Temp.Next;
end loop;
end if;
return Count;
end Count_Waiting;
end System.Tasking;